home *** CD-ROM | disk | FTP | other *** search
/ Deutsche Edition 1 / Deutsche Edition 1.iso / amok / 041-050 / amok41 / spiele / mastermind / txt / mastermind.mod < prev    next >
Text File  |  1993-11-04  |  11KB  |  395 lines
  1. (*********************************************************************
  2.  *
  3.  *  :Program.        Mastermind
  4.  *  :Author.        Hans Schafft
  5.  *  :Address.        Landfriedstraße 1A - Hinterhaus
  6.  *  :Address.        6900 Heidelberg
  7.  *  :Phone.        06221 - 22416
  8.  *  :Version.        1.3
  9.  *  :Date.        22.6.1990
  10.  *  :Copyright.        PD
  11.  *  :Language.        Modula-II
  12.  *  :Translator.    M2Amiga
  13.  *
  14.  *********************************************************************)
  15.  
  16. MODULE Mastermind;
  17.  
  18. FROM Abbruch        IMPORT    ZeigeAbbruch;
  19. FROM MODUS        IMPORT    Modus;
  20. FROM WARNUNG        IMPORT    DruckerAn;
  21. FROM BESTENLISTE    IMPORT    BestenListe;
  22. FROM BildMalen        IMPORT    Malen;
  23. FROM SCREEN        IMPORT    FensterAuf,ScreenAuf;
  24. FROM VonWem        IMPORT    ShowReq;
  25. FROM Gadget        IMPORT    gadNum, FestGadgetAufbau, TipFuellen,
  26.                 Auswerten,StellenUndFarben,
  27.                 GadgetsLoeschen, FlexGadgetAufbau;
  28. FROM Graphics        IMPORT    SetAPen,RectFill,GetRGB4,SetRGB4,SetRast,jam1;
  29. FROM Intuition        IMPORT    GadgetPtr, CloseWindow, WindowPtr, CurrentTime,
  30.                 CloseScreen, ScreenPtr, keyCodeQ, IntuiText,
  31.                 RemoveGadget, selectDown, ScreenToFront,
  32.                 GetPrefs,SetPrefs,Preferences,
  33.                 IntuiMessagePtr, IDCMPFlags, IDCMPFlagSet;
  34. FROM Exec           IMPORT  MemReqs, MemReqSet, WaitPort, ReplyMsg, GetMsg;
  35. FROM Arts        IMPORT    AllLevelTermProc, Assert, Requester, Terminate;
  36. FROM RandomNumber    IMPORT    RND, PutSeed;
  37. FROM SYSTEM        IMPORT    ADDRESS, LONGSET, ADR;
  38. FROM ASCII        IMPORT    ht,cr,lf;
  39. FROM FileSystem     IMPORT    Lookup,Close,Response,File,WriteChar,WriteBytes;
  40. FROM FileMessage    IMPORT    ResponseText,StrPtr;
  41.  
  42.  
  43. VAR x,stellenAnzahl    : INTEGER;
  44.     y,farbAnzahl,YPos    : INTEGER;
  45.     zufallsKombination    : ARRAY [1..15] OF INTEGER;
  46.     rateVersuch        : ARRAY [1..15] OF INTEGER;
  47.     wiPtr        : WindowPtr;
  48.     scPtr        : ScreenPtr;
  49.     sfrgb        : ARRAY [16..19],[1..3] OF CARDINAL;
  50.     aktuelleFarbe    : LONGINT;
  51.     drucken,modus    : BOOLEAN;
  52.     dr            : File;
  53.     prefs        : Preferences;
  54.  
  55.  
  56. CONST OK = 15;
  57.       HILFE = 16;
  58.  
  59. (***************************************************************)
  60. PROCEDURE DruckerAusgabe(ja : BOOLEAN);
  61. VAR strPtr : StrPtr;
  62. BEGIN
  63.   IF ja THEN
  64.     drucken := DruckerAn(wiPtr);
  65.     IF drucken THEN
  66.       Lookup(dr,"PRT:",0,FALSE);
  67.       ResponseText(dr.res,strPtr);
  68.       Assert(dr.res = done,strPtr);
  69.     END;
  70.   ELSE
  71.     IF drucken THEN
  72.       Close(dr);
  73.     END;
  74.   END;
  75. END DruckerAusgabe;
  76.  
  77. (***************************************************************)
  78. PROCEDURE ErstelleZufallsKombination;
  79. VAR s,m : LONGINT;
  80.     y,test : INTEGER;
  81.     wh,einfach : BOOLEAN;
  82. BEGIN
  83.   IF stellenAnzahl > farbAnzahl THEN
  84.     einfach  := FALSE;
  85.   ELSE
  86.     einfach := Modus(wiPtr);
  87.   END;
  88.  
  89.   IF einfach THEN
  90.     FOR y := 1 TO stellenAnzahl DO
  91.       rateVersuch[y] := y;
  92.     END;
  93.   ELSE
  94.     FOR y := 1 TO stellenAnzahl DO
  95.       rateVersuch[y] := 1;
  96.     END;
  97.   END;
  98.  
  99.   CurrentTime(ADR(s),ADR(m));
  100.   PutSeed(m);
  101.   zufallsKombination[1] := RND(farbAnzahl)+1;
  102.   FOR x := 2 TO stellenAnzahl  DO
  103.     IF einfach THEN
  104.       wh := TRUE;
  105.       WHILE wh DO
  106.         test := RND(farbAnzahl)+1;
  107.         wh := FALSE;
  108.         FOR y := 1 TO x-1 DO
  109.           IF zufallsKombination[y] = test THEN
  110.             wh := TRUE;
  111.           END;
  112.         END;
  113.       END;
  114.       zufallsKombination[x] := test;
  115.     ELSE
  116.       zufallsKombination[x] := RND(farbAnzahl)+1;
  117.     END;
  118.   END;
  119. END ErstelleZufallsKombination;
  120.  
  121. (***************************************************************)
  122. PROCEDURE AusDruck(fs,nf : INTEGER);
  123. VAR actual : LONGINT;
  124. BEGIN
  125.   IF drucken THEN
  126.     IF fs = HILFE THEN
  127.       WriteBytes(dr,ADR("Das waren "),10,actual);
  128.       IF nf < 10 THEN
  129.         WriteChar(dr,CHAR(48+nf));
  130.       ELSE
  131.         WriteChar(dr,"1");
  132.         WriteChar(dr,CHAR(38+nf));
  133.       END;
  134.       WriteBytes(dr,ADR(" Hilfen !!"),10,actual);
  135.       WriteChar(dr,cr);
  136.       WriteChar(dr,lf);
  137.     ELSE
  138.       FOR x := 1 TO stellenAnzahl DO
  139.         WriteChar(dr,CHAR(rateVersuch[x]+64));
  140.         WriteChar(dr," ");
  141.       END;
  142.       WriteChar(dr,ht);
  143.       WriteChar(dr,CHAR(fs+48));
  144.       WriteChar(dr,ht);
  145.       WriteChar(dr,CHAR(nf+48));
  146.       WriteChar(dr,cr);
  147.       WriteChar(dr,lf);
  148.     END;
  149.   END;
  150. END AusDruck;
  151.  
  152. (***************************************************************)
  153. PROCEDURE TipAuswerten() : BOOLEAN;
  154. VAR rv,zk : ARRAY [1..15] OF INTEGER;
  155.     x,y,farbeUndStelle,nurFarbe : INTEGER;
  156. BEGIN
  157.   FOR x := 1 TO 15 DO
  158.     rv[x] := rateVersuch[x];
  159.     zk[x] := zufallsKombination[x];
  160.   END;
  161.   farbeUndStelle := 0;
  162.   nurFarbe := 0;
  163.   FOR x := 1 TO stellenAnzahl DO
  164.     IF rv[x] = zk[x] THEN
  165.       INC(farbeUndStelle);
  166.       rv[x] := -1;
  167.       zk[x] := -1;
  168.     END;
  169.   END;
  170.  
  171.   IF farbeUndStelle = stellenAnzahl THEN
  172.     Auswerten(farbeUndStelle,OK);
  173.     AusDruck(farbeUndStelle,nurFarbe);
  174.     RETURN TRUE;
  175.   ELSE
  176.     FOR x := 1 TO stellenAnzahl  DO
  177.       FOR y := 1 TO stellenAnzahl  DO
  178.         IF (rv[x] = zk[y]) AND (rv[x] # -1) THEN
  179.           INC(nurFarbe);
  180.           rv[x] := -1;
  181.           zk[y] := -1;
  182.         END;
  183.       END;
  184.     END;
  185.     Auswerten(farbeUndStelle,nurFarbe);
  186.     AusDruck(farbeUndStelle,nurFarbe);
  187.     RETURN FALSE;
  188.   END;
  189. END TipAuswerten;
  190.  
  191. (***************************************************************)
  192. PROCEDURE OrigPointerRetten;
  193. VAR x,y : LONGINT;
  194.     lc    : ARRAY [16..19] OF LONGCARD;
  195. BEGIN
  196.   FOR x := 16 TO 19 DO
  197.     lc[x] := GetRGB4(scPtr^.viewPort.colorMap,x);
  198.     lc[x] := lc[x]  DIV 16;
  199.     FOR y := 1 TO 3 DO
  200.       sfrgb[x,y] := lc[x] MOD 16;
  201.       lc[x] := lc[x] DIV 16;
  202.     END;
  203.   END;
  204. END OrigPointerRetten;
  205.  
  206. (***************************************************************)
  207. PROCEDURE FarbPointer;
  208. VAR x,lc : LONGCARD;
  209.     r,g,b : CARDINAL;
  210. BEGIN
  211.   lc := GetRGB4(scPtr^.viewPort.colorMap,aktuelleFarbe);
  212.   b := lc MOD 16; lc := lc DIV 16;
  213.   g := lc MOD 16; lc := lc DIV 16;
  214.   r := lc MOD 16;
  215.   FOR x := 16 TO 19 DO
  216.     SetRGB4(ADR(scPtr^.viewPort),x,r,g,b);
  217.   END;
  218. END FarbPointer;
  219.  
  220. (***************************************************************)
  221. PROCEDURE OrigPointer;
  222. VAR x : CARDINAL;
  223. BEGIN
  224.   FOR x := 16 TO 19 DO
  225.     SetRGB4(ADR(scPtr^.viewPort),x,sfrgb[x,1],sfrgb[x,2],sfrgb[x,3])
  226.   END;
  227. END OrigPointer;
  228.  
  229. (***************************************************************)
  230. PROCEDURE LosGehts() : BOOLEAN;
  231. VAR
  232.   gadPtr    : GadgetPtr;
  233.   gadNr,z    : INTEGER;
  234.   hilfen,y    : INTEGER;
  235.   versuche,x    : INTEGER;
  236.   msgPtr    : IntuiMessagePtr;
  237.   class     : IDCMPFlagSet;
  238.   code        : CARDINAL;
  239.   spielEnde,help : BOOLEAN;
  240.  
  241. BEGIN
  242.   spielEnde := FALSE;help := FALSE;
  243.   drucken := FALSE;
  244.   hilfen := 0;versuche := 0;
  245.   REPEAT
  246.     WaitPort(wiPtr^.userPort);
  247.     LOOP
  248.       msgPtr := GetMsg(wiPtr^.userPort);
  249.       IF msgPtr=NIL THEN EXIT END;
  250.  
  251.       x     := msgPtr^.mouseX;
  252.       y     := msgPtr^.mouseY;
  253.       class := msgPtr^.class;
  254.       code  := msgPtr^.code;
  255.       gadPtr := msgPtr^.iAddress;
  256.       gadNr := gadPtr^.gadgetID;
  257.  
  258.       ReplyMsg(msgPtr);
  259.  
  260.       IF (class = IDCMPFlagSet{gadgetUp}) THEN
  261.         IF NOT help AND (gadNr > 16) AND (gadNr < (17 + farbAnzahl)) THEN
  262.           aktuelleFarbe := LONGINT(gadNr - 16);
  263.           FarbPointer;
  264.         ELSIF (gadNr > 30) THEN
  265.           IF help THEN
  266.             OrigPointer;
  267.             TipFuellen(gadNr,zufallsKombination[gadNr-30]);
  268.             rateVersuch[gadNr-30] := zufallsKombination[gadNr-30];
  269.             INC(hilfen);
  270.           ELSE
  271.             TipFuellen(gadNr,CARDINAL(aktuelleFarbe));
  272.             rateVersuch[gadNr - 30] := aktuelleFarbe;
  273.           END;
  274.         END;
  275.  
  276.         CASE gadNr OF
  277.         | INTEGER(ok)    : IF NOT help THEN
  278.                       INC(versuche);
  279.                      FOR z := 31 TO stellenAnzahl+30 DO
  280.                        TipFuellen(z,rateVersuch[z-30]);
  281.                      END;
  282.                      IF TipAuswerten() THEN
  283.                                spielEnde := TRUE;
  284.                  ELSE
  285.                                spielEnde := FALSE;
  286.                              END;
  287.                    END;
  288.         | INTEGER(hilfe) : help :=  NOT help;
  289.                    IF help THEN
  290.                    SetRGB4(ADR(scPtr^.viewPort),0,0,0,8);
  291.                  ELSE
  292.                  Auswerten(HILFE,HILFE);
  293.                  AusDruck(HILFE,hilfen);
  294.                  SetRGB4(ADR(scPtr^.viewPort),0,0,0,0);
  295.                    END;
  296.         | INTEGER(einaus): drucken := NOT drucken;
  297.                    DruckerAusgabe(drucken);
  298.         | INTEGER(info)  : ShowReq(wiPtr);
  299.         | INTEGER(neu)   : SetRast(wiPtr^.rPort,0);
  300.                GadgetsLoeschen;
  301.                SetRGB4(ADR(scPtr^.viewPort),0,0,0,0);
  302.                RETURN FALSE;
  303.         | INTEGER(ende)  : IF ZeigeAbbruch(wiPtr) THEN
  304.                       Terminate(0);
  305.                      END;
  306.         ELSE
  307.         END;
  308.       ELSIF NOT help AND (class = IDCMPFlagSet{mouseMove}) THEN
  309.         IF (x > 510) OR ((x > 400) AND (x < 450)) THEN
  310.           OrigPointer;
  311.         ELSE
  312.           FarbPointer;
  313.         END;
  314.       ELSIF (class = IDCMPFlagSet{rawKey}) AND (code = keyCodeQ) THEN
  315.         spielEnde := TRUE;
  316.       ELSE
  317.       END;
  318.       IF spielEnde THEN EXIT END;
  319.     END; (* LOOP *)
  320.   UNTIL spielEnde;
  321.   SetRGB4(ADR(scPtr^.viewPort),0,8,0,0);
  322.   Close(dr);
  323.  
  324.   spielEnde := FALSE;
  325.   REPEAT
  326.     WaitPort(wiPtr^.userPort);
  327.     LOOP
  328.       msgPtr := GetMsg(wiPtr^.userPort);
  329.       IF msgPtr=NIL THEN EXIT END;
  330.  
  331.       class := msgPtr^.class;
  332.       code  := msgPtr^.code;
  333.       gadPtr := msgPtr^.iAddress;
  334.       gadNr := gadPtr^.gadgetID;
  335.  
  336.       ReplyMsg(msgPtr);
  337.  
  338.       IF (class = IDCMPFlagSet{gadgetUp}) THEN
  339.         CASE gadNr OF
  340.           | INTEGER(neu)   : SetRast(wiPtr^.rPort,0);
  341.                        GadgetsLoeschen;
  342.                  SetRGB4(ADR(scPtr^.viewPort),0,0,0,0);
  343.                  RETURN FALSE;
  344.           | INTEGER(info)  : ShowReq(wiPtr);
  345.           | INTEGER(best)  : SetRast(wiPtr^.rPort,0);
  346.                  BestenListe(wiPtr,stellenAnzahl,farbAnzahl,
  347.                                   versuche,hilfen);
  348.                        spielEnde := TRUE;
  349.           | INTEGER(ende)  : IF ZeigeAbbruch(wiPtr) THEN
  350.                       Terminate(0);
  351.                        END;
  352.         ELSE
  353.         END;
  354.       ELSIF (class = IDCMPFlagSet{rawKey}) AND (code = keyCodeQ) THEN
  355.         help := FALSE;spielEnde := TRUE;
  356.       ELSE
  357.       END;
  358.       IF spielEnde THEN EXIT END;
  359.     END; (* LOOP *)
  360.   UNTIL spielEnde;
  361.   SetRast(wiPtr^.rPort,0);
  362.   GadgetsLoeschen;
  363.   SetRGB4(ADR(scPtr^.viewPort),0,0,0,0);
  364.   RETURN help;
  365. END LosGehts;
  366.  
  367. (***************************************************************)
  368. PROCEDURE AllesZu;
  369. BEGIN
  370.   IF wiPtr # NIL THEN CloseWindow(wiPtr); END;
  371.   IF scPtr # NIL THEN CloseScreen(scPtr); END;
  372.   IF drucken THEN Close(dr); END;
  373. END AllesZu;
  374.  
  375. (***************************************************************)
  376. (***************************************************************)
  377. BEGIN
  378.   wiPtr := NIL;scPtr := NIL;
  379.   AllLevelTermProc(AllesZu);
  380.   ScreenAuf(scPtr);
  381.   FensterAuf(scPtr,wiPtr);
  382.   OrigPointerRetten;
  383.   REPEAT
  384.     Malen(wiPtr);
  385.     FestGadgetAufbau(wiPtr);
  386.     OrigPointer;
  387.     stellenAnzahl := 8;
  388.     farbAnzahl := 8;
  389.     aktuelleFarbe := 1;
  390.     StellenUndFarben(stellenAnzahl,farbAnzahl);
  391.     FlexGadgetAufbau(stellenAnzahl);
  392.     ErstelleZufallsKombination;
  393.   UNTIL LosGehts();
  394. END Mastermind.
  395.